unit Sets;

{$IFDEF FPC}
  {$MODE Delphi}{$H+}
{$ENDIF}

interface

uses
  Classes, SysUtils, thrds, fcUtils, Windows;

type

  IQueue = interface
    function GetCount: Integer;
    function GetSize: Integer;
    procedure Push(o: TObject);
    function Pop: TObject;
    property Size:Integer read GetSize;
    property Count:Integer read GetCount;
  end;

  IPool = interface
    procedure Put(const o: TObject);
    function Get: TObject; overload;
    procedure Get(var o); overload;
  end;

  function SemQueue(Size:Integer): IQueue;
  function Pool(ObjectClass: TClass; Size: Integer): IPool;

implementation

type { TSemQueue }

  TSemQueue = class(TInterfacedObject, IQueue)
  private
    Data: array of TObject;
    FSize: Integer;
    FCount: Integer;
    Head: integer;
    Tail: integer;
    HeadCS: TRTLCriticalSection;
    TailCS: TRTLCriticalSection;
    Spaces: ISemaphore;
    Items: ISemaphore;
    function GetCount: Integer;
    function GetSize: Integer;
  public
    constructor Create(size: Integer);
    procedure Push(o: TObject);
    function Pop: TObject;
    property Size:Integer read GetSize;
    property Count:Integer read GetCount;
  end;

  function SemQueue(Size: Integer): IQueue;
  begin
    Result := TSemQueue.Create(size);
  end;

constructor TSemQueue.Create(size: Integer);
begin
  InitializeCriticalSection(HeadCS);
  InitializeCriticalSection(TailCS);

  FSize := size;
  SetLength(Data, FSize);

  Spaces := Semaphore(FSize, FSize);
  Items  := Semaphore(FSize, 0);
end;

procedure TSemQueue.Push(o: TObject);
begin
  Spaces.Wait;
  EnterCriticalSection(HeadCS); // HeadMutex.Lock;
    Data[Head] := o;
    IncMax(Head, FSize);
    Inc(FCount);
  LeaveCriticalSection(HeadCS); // HeadMutex.Unlock;
  Items.Signal;
end;

function TSemQueue.Pop: TObject;
begin
  Items.Wait;
  EnterCriticalSection(TailCS); // TailMutex.Lock;
    Result := Data[Tail];
    IncMax(Tail, FSize);
    Dec(FCount);
  LeaveCriticalSection(TailCS); // TailMutex.Unlock;
  Spaces.Signal;
end;

function TSemQueue.GetCount: Integer;
begin
  Result := FCount;
end;

function TSemQueue.GetSize: Integer;
begin
  Result := FSize;
end;

type

  TQueue = class(TInterfacedObject, IQueue)
    Data: array of TObject;
    FSize: Integer;
    FCount: Integer;
    Head: integer;
    Tail: integer;
    function GetCount: Integer;
    function GetSize: Integer;
  public
    constructor Create(size: Integer);
    procedure Push(o: TObject);
    function Pop: TObject;
    property Size:Integer read GetSize;
    property Count:Integer read GetCount;
  end;

  function Queue(Size: Integer): IQueue;
  begin
    Result := TQueue.Create(size);
  end;

constructor TQueue.Create(size: Integer);
begin
  FSize := size;
  SetLength(Data, FSize);
end;

// Empty Queue                            After 1 Push
// +---+---+---+---+---+---+---+---+      +---+---+---+---+---+---+---+---+
// |   |   |   |   |   |   |   |   |      | X |   |   |   |   |   |   |   |
// +---+---+---+---+---+---+---+---+      +---+---+---+---+---+---+---+---+
//  I/O                                     O   I

// After 5 Pushes and 2 Pops              Wrapped after 9 pushes and 4 Pops
// +---+---+---+---+---+---+---+---+      +---+---+---+---+---+---+---+---+
// |   |   | X | X | X |   |   |   |      | X |   |   |   | X | X | X | X |
// +---+---+---+---+---+---+---+---+      +---+---+---+---+---+---+---+---+
//           O           I                      I           O

// Full queue                             After 1 Pop
// +---+---+---+---+---+---+---+---+      +---+---+---+---+---+---+---+---+
// | X | X | X | X | X | X | X | X |      | X | X |   | X | X | X | X | X |
// +---+---+---+---+---+---+---+---+      +---+---+---+---+---+---+---+---+
//                       O/I                        I   O

// Com a fila cheia, I e O serão iguais, o que signifique que somente
// Será possível inserir novo item, quando O for atualizado.

procedure TQueue.Push(o: TObject);
var
  t:Integer;
begin
  t := (InterlockedIncrement(Tail)-1) div FSize;
  InterlockedIncrement(FCount);
  while FCount >= Size do Sleep(0); // Acho que isso tá errado!
  Data[t] := o;
end;

function TQueue.Pop: TObject;
var
  h:Integer;
begin
  h := InterlockedIncrement(Head) div FSize;
  InterLockedDecrement(FCount);
  while FCount <= 0 do Sleep(0);
  Result := Data[h];
end;

function TQueue.GetCount: Integer;
begin
  Result := FCount;
end;

function TQueue.GetSize: Integer;
begin
  Result := FSize;
end;

type { TPool }

  TPool = class(TQueue, IPool)
    procedure Put(const o: TObject);
    procedure Get(var o); overload;
    function Get: TObject; overload;
 end;

function Pool(ObjectClass: TClass; Size: Integer): IPool;
var
  i: Integer;
begin
  Result := TPool.Create(Size);
  for i := 1 to Size do
    Result.Put(ObjectClass.Create);
end;

{ TPool }

procedure TPool.Put(const o: TObject);
begin
  Push(o);
end;

procedure TPool.Get(var o);
begin
  TObject(o) := Pop;
end;

function TPool.Get: TObject;
begin
  Result := Pop;
end;

end.

